home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1994 August: Tool Chest / Dev.CD Aug 94.toast / Tool Chest / Development Platforms / Macintosh Common Lisp Related / User Contributions / applescript-from-lisp / applescript⁄appleevents / AppleScript.lisp < prev    next >
Encoding:
Text File  |  1994-06-16  |  12.8 KB  |  321 lines  |  [TEXT/CCL2]
  1. ;;; -*- package: ASTOOLS -*-
  2.  
  3. (in-package "ASTOOLS")
  4.  
  5. (require :aestuff "ccl:applescript/appleevents;aestuff")
  6. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  7. ;;;  AppleScript.lisp - T. Bonura 2/3/94
  8. ;;;
  9. ;;;  Note that this is ® Apple Computer, Inc.  1994.  All rights reserved.
  10. ;;;  This file may not be distributed without the consent of Apple Computer.
  11. ;;;
  12. ;;;  Class definitions for creating applescript CLOS instances.
  13. ;;;    With thanks to Bob Strong
  14. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  15. ;;;  Changes:
  16. ;;  Fri, Mar 11, 1994  3:02 PM Changed EXECUTE-APPLESCRIPT to check for an open
  17. ;;  component and also a compiled script id.
  18. ;;  Fri, Mar 11, 1994  3:02 PM Changed EXTRACT-THE-RESULT so that it extracts
  19. ;;  the right thing now - which seems to be an id of 1+ the compiled-script-id.
  20. ;;;  Fri, Mar 25, 1994  2:30 PM  Added recordability to the  functionality of the ASO. 
  21.  
  22. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  23. ;;;  NOTE:  Need to work on error handling - Bonura 3/17/94 - 12:10 PM
  24. ;;;  Hmmmm, do I really need this?? -Probably not!
  25. (DEFTRAP _OSASetDefaultTarget 
  26.          ((SCRIPTINGCOMPONENT (:POINTER :COMPONENTINSTANCERECORD)) 
  27.           (TARGET (:POINTER :AEADDRESSDESC)))
  28.          (:STACK :SIGNED-LONG)
  29.   (:STACK-TRAP #xA82A :D0 0 SCRIPTINGCOMPONENT TARGET ((+ (ASH 4 16) 1029)
  30.                                                        :SIGNED-LONGINT)))
  31.  
  32.  
  33. (DEFCONSTANT $AppleScript :|ascr| "The applescript scripting component")
  34. (DEFCONSTANT $GeneralScriptingComponent :|cscr| "The general scripting component")
  35. (DEFCONSTANT $HyperTalk :|htlk| "The hypertalk scripting component")
  36.  
  37. (export '(APPLESCRIPT-OBJECT EXECUTE-APPLESCRIPT APPLESCRIPT-OBJECT
  38.           EXECUTE-APPLESCRIPT EXTRACT-THE-RESULT EDIT-SCRIPT)) 
  39. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  40. ;;;    Class:  APPLESCRIPT-OBJECT
  41. ;;;    OPEN-COMPONENT ((ASO APPLESCRIPT-OBJECT)) "opens a scripting component
  42. ;;;    and sets the value of the component slot to a pointer
  43. ;;;    COMPILE-APPLESCRIPT ((ASO APPLESCRIPT-OBJECT)) "compiles the script
  44. ;;;    which is in the script slot"
  45. ;;;    EXECUTE-APPLESCRIPT ((ASO APPLESCRIPT-OBJECT)) "What do you think?"
  46. ;;;   EDIT-SCRIPT ((ASO APPLESCRIPT-OBJECT))
  47. ;;;   CLEANUP ((ASO APPLESCRIPT-OBJECT)) 
  48. ;;;   DISPOSE-SCRIPT ((ASO APPLESCRIPT-OBJECT))
  49. ;;;   DISPLAY-RESULT ((ASO APPLESCRIPT-OBJECT))
  50. ;;;   EXTRACT-THE-RESULT ((ASO APPLESCRIPT-OBJECT))
  51. ;;;    ******  Recording *****
  52. ;;;   START-RECORDING ((ASO APPLESCRIPT-OBJECT))
  53. ;;;   STOP-RECORDING ((ASO APPLESCRIPT-OBJECT)) "When we 
  54. ;;;   stop recording, we add the decompiled script to the script slot"
  55. ;;;   DECOMPILE-SCRIPT ((ASO APPLESCRIPT-OBJECT))
  56. ;;;    ** ASO = AppleScriptObject **
  57. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  58. (DEFCLASS APPLESCRIPT-OBJECT (standard-object)
  59.   ((script :initform NIL :initarg :script :accessor script)
  60.    (application-name :initform NIL :initarg :application-name :accessor
  61.                      application-name) 
  62.    (scripting.component.type :initform NIL :initarg :scripting-component-type
  63.                              :accessor scripting-component-type)
  64.    ;;  NOTE:  the as.target slot is not currently used
  65.    (as.target :initform NIL :initarg :target :accessor as-target)
  66.    (break.on.error :initarg :break-on-error :accessor break-on-error)
  67.    (compiled.script :initform NIL :initarg NIL :accessor compiled-script)
  68.    (compiled.script.id :initform NIL :initarg NIL :accessor compiled-script-id) 
  69.    (component :initform nil :initarg :component :accessor component)
  70.    (returned.value :accessor returned-value)
  71.    )
  72.   (:default-initargs
  73.     :scripting-component-type $AppleScript
  74.     :break-on-error t)
  75.   )
  76. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  77. (DEFGENERIC OPEN-COMPONENT (APPLESCRIPT-OBJECT)
  78.   (:documentation "Opens a scripting component")
  79.   )
  80.  
  81. (DEFMETHOD OPEN-COMPONENT ((ASO APPLESCRIPT-OBJECT))
  82.   (setf (component ASO)
  83.         (#_OpenDefaultComponent #$kOSAComponentType 
  84.          (scripting-component-type ASO))))
  85. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  86. (DEFGENERIC COMPILE-APPLESCRIPT (APPLESCRIPT-OBJECT)
  87.   (:documentation "Compile the applescript")
  88.   )
  89.  
  90. (DEFMETHOD COMPILE-APPLESCRIPT ((ASO APPLESCRIPT-OBJECT))
  91.   (unless (component aso)
  92.     (open-component aso))
  93.   (with-pointers ((as (component ASO)))
  94.     (let ((text (extract-script-text (script ASO))))
  95.       (with-aedescs (source)
  96.         (let ((size (length text)))
  97.           (%vstack-block (buff size)
  98.             (dotimes (i size)
  99.               (%put-byte buff (char-code (char text i)) i))
  100.             (#_AECreateDesc #$typeChar buff size source)))
  101.         (rlet ((id :OSAID))
  102.           (%put-long id #$kOSANullScript)
  103.           (let ((err (#_OSACompile as source 0 id)))
  104.             (cond ((zerop err)
  105.                    ;;(format t "OK Seems to compile")
  106.                    (setf (compiled-script aso) t)
  107.                    (setf (compiled-script-id ASO) (%get-long id)))
  108.                   (t
  109.                    (if (break-on-error ASO)
  110.                      (error (script-error as)))
  111.                    (values nil err))))))
  112.       )
  113.     )
  114.   )
  115. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  116. (DEFGENERIC EXECUTE-APPLESCRIPT (APPLESCRIPT-OBJECT)
  117.   (:documentation "Execute the script on the target")
  118.   )
  119.  
  120. (DEFMETHOD EXECUTE-APPLESCRIPT ((ASO APPLESCRIPT-OBJECT))
  121.   ;;  in case we try to execute without having an open scripting component
  122.   (unless (component ASO)
  123.       (open-component ASO))
  124.   ;;  whenever the script is edited in the script editor, the value of
  125.   ;;  compiled-script is set to nil 
  126.   (unless (compiled-script aso)
  127.     (compile-applescript ASO))
  128.   (with-pointers ((as (component ASO)))
  129.     ;;  maybe not yet compiled?
  130.     (unless (compiled-script-id ASO)
  131.       (compile-applescript ASO))
  132.     (rlet ((result-id :OSAID))
  133.       (let* ((id (compiled-script-id ASO))
  134.              (err (#_OSAExecute as id 0 0 result-id)))
  135.         (cond ((zerop err)
  136.                ;(%get-long result-id)
  137.                (extract-the-result aso))
  138.               (t
  139.                (if (break-on-error ASO)
  140.                      (error (script-error as)))
  141.                (values nil err)))))
  142.     )
  143.   )
  144.  
  145. (DEFMETHOD EXTRACT-THE-RESULT ((ASO APPLESCRIPT-OBJECT))
  146.   (with-aedescs (source)
  147.     ;;  the second parameter to OSADisplay should be an id.  If I pass the id
  148.     ;;  which is generated when I compile the script I don't necessarliy get the
  149.     ;;  right thing - if I pass 1 + that value I do!. 
  150.     ;;  What's going on?
  151.     (let ((err (#_OSADisplay (component ASO) (1+ (compiled-script-id aso))
  152.                 #$typeChar 0 source)))
  153.       (cond ((zerop err)
  154.              (setf (returned-value aso) 
  155.                    (get-string (rref source AEDesc.dataHandle))))
  156.             (t (values nil err))))))
  157.  
  158. (DEFMETHOD DISPLAY-RESULT ((ASO APPLESCRIPT-OBJECT))
  159.   (format t "~%~A" (extract-the-result ASO)))
  160.   
  161. (DEFMETHOD DISPOSE-SCRIPT ((ASO APPLESCRIPT-OBJECT))
  162.   (let ((as (component ASO))
  163.         (id (compiled-script-id ASO)))
  164.   (if (and as id)
  165.     (assert (zerop (#_OSADispose as id))))
  166.   )
  167.   )
  168.  
  169. (DEFMETHOD CLEANUP ((ASO APPLESCRIPT-OBJECT))
  170.   (dispose-script ASO)            ; what else??
  171.   )
  172.  
  173. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  174. (DEFGENERIC EDIT-SCRIPT (APPLESCRIPT-OBJECT)
  175.   (:documentation "Bring up a script editor on the script")
  176.   )
  177.  
  178.  
  179. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  180. ;;  Methods for dealing with error conditions
  181. ;;
  182. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  183.  
  184.  
  185. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  186. ;;;
  187. ;;;
  188. ;;;        Recording From Recordable Applications
  189. ;;;  The following allows for recording to be turned on. 
  190. ;;;  Actions are recorded to the compiled script in the
  191. ;;;  applescript object.
  192. ;;;
  193. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  194. (DEFMETHOD START-RECORDING ((aso APPLESCRIPT-OBJECT))
  195.   ;;  tell the applescript object to start recording
  196.   ;;  tell the object to open a scripting component
  197.   (open-component aso)
  198.   ;;  if there is a compiledscriptid then we use it
  199.   ;;  otherwise we use the null script
  200.   (unless (compiled-script-id aso)
  201.     (with-pointers ((as (component aso)))
  202.       (rlet ((id :OSAID))
  203.         (%put-long id #$KOSANullScript)
  204.         (let ((oserr (#_OSAStartRecording as id)))
  205.           (if (zerop oserr)
  206.             (progn
  207.               (format t "Recording is on.~%")
  208.               (setf (compiled-script-id aso) (%get-long id)))
  209.             (if (break-on-error ASO)
  210.               (error (script-error as)))))))))
  211.  
  212.  
  213. (DEFMETHOD STOP-RECORDING ((aso APPLESCRIPT-OBJECT))
  214.   (with-pointers ((as (component aso)))
  215.     (let ((oserr (#_OSAStopRecording as (compiled-script-id aso))))
  216.       
  217.       (cond ((zerop oserr)
  218.              (decompile-script aso)
  219.              (format t "Recording is off.~%"))
  220.             (t
  221.              (if (break-on-error ASO)
  222.                (error (script-error as))))))))
  223.  
  224.  
  225. (DEFMETHOD DECOMPILE-SCRIPT ((aso applescript-object))
  226.   ;;  extract the script from the compiled script.  Most
  227.   ;;  useful when doing recording
  228.   (with-pointers ((as (component aso)))
  229.     (let* ((descObj (make-instance 'ccl::aedesc :type #$TypeChar))
  230.            (id (compiled-script-id aso))
  231.            (err (#_OSAGetSource as id #$typeChar
  232.                    (ccl::getDescRecPtr descObj))))
  233.       (cond ((zerop err)
  234.              ;;  extract the text from the descriptor, then
  235.              ;;  add the script to the script slot of the
  236.              ;;  object and inform the object that the
  237.              ;;  script has changed
  238.              (setf (script aso)
  239.                    (get-string (rref (ccl::getDescRecPtr descObj)
  240.                         AEDesc.dataHandle))
  241.                    (compiled-script aso) t))
  242.             (t (if (break-on-error ASO)
  243.                      (error (script-error as)))
  244.                )
  245.             )
  246.       )
  247.     )
  248.   )
  249.  
  250. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  251. ;;  Utilities
  252. ;;
  253. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  254.  
  255. (DEFUN EXTRACT-SCRIPT-TEXT (text)
  256.   "Remove any tabs and linefeeds from the text if the script should be of short
  257. form, otherwise if the script is of the type 'tell, end tell' just return the
  258. whole thing"
  259.   ;;  see if the last word of the text is "tell"
  260.   (if (string= "tell" (reverse (string-downcase (subseq (reverse text) 0 4))))
  261.     text
  262.     (strip-lf&tab text)))
  263.  
  264. (DEFUN STRIP-LF&TAB (string)
  265.   "Removes linefeeds and tabs from a copy of string"
  266.   (substitute-if #\space #'(lambda (char)
  267.                  (or (char= char #\return)
  268.                      (char= char #\tab)))
  269.              string))
  270.  
  271. (DEFUN GET-STRING (data)
  272.   (let* ((size (#_GetHandleSize data))
  273.          (text (make-string size)))
  274.     (dotimes (i size)
  275.       (setf (char text i) (code-char (%hget-byte data i))))
  276.     text))
  277.  
  278. (DEFUN SCRIPT-ERROR (as)
  279.   (with-aedescs (err)
  280.     (if (/= (#_OSAScriptError as #$kOSAErrorMessage #$typeChar err) #$noErr)
  281.       ""
  282.       (get-string (rref err AEDesc.dataHandle)))))
  283.  
  284.  
  285. (provide :appleScript)
  286.  
  287.  
  288. #|
  289.  
  290. (setf ttest (make-instance 'applescript-object))
  291. (start-recording ttest)
  292. (stop-recording ttest)
  293. (inspect ttest)
  294. (execute-applescript ttest)
  295.  
  296. (decompile-script ttest)
  297.  
  298.  
  299. (setf astest (make-instance 'APPLESCRIPT-OBJECT
  300.                :script "tell application \"Eudora\" to get the number of Message of Mailbox \"In\" of Mail Folder \"\""
  301.                :application-name "Eudora"
  302.                ))
  303. (open-component astest)
  304. (compile-applescript astest)
  305. (execute-applescript astest)
  306. (edit-script astest)
  307. (cleanup astest)
  308. Here are some scripts which seem to work:
  309. "tell application \"Eudora2.0.2a1d-2.1994\" to make new Message at the end of Mailbox \"out\" of Mail Folder \"\""
  310. "tell application \"Eudora2.0.2a1d-2.1994\" to Connect with send and check"
  311. "tell application \"Eudora2.0.2a1d-2.1994\" to Reply Message 4 of Mailbox \"In\" of Mail Folder \"\""
  312. "tell application \"Eudora2.0.2a1d-2.1994\" to Redirect the last Message of Mailbox \"In\" of Mail Folder \"\""
  313. "tell application \"Eudora2.0.2a1d-2.1994\" to get the Field \"to\" of the last Message of Mailbox \"In\" of Mail Folder \"\""
  314. "tell application \"Eudora2.0.2a1d-2.1994\" to get the number of Message of Mailbox \"In\" of Mail Folder \"\""
  315. "tell application \"Eudora2.0.2a1d-2.1994\" to Connect without Send"
  316.  
  317. ;; here's one for :|quil|
  318. "tell \"Scriptable Text Editor\" to set the size of word 1 of window 1 of application \"Scriptable Text Editor\" to 48"
  319.  
  320. |#
  321.